home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / feelflex.lex < prev    next >
Text File  |  1992-12-22  |  13KB  |  615 lines
  1. /* -*- C -*- */
  2.  
  3. /* EuLisp lexer
  4.  *
  5.  * Russell Bradford, Bath 1990
  6.  * Based on work by J. Bejar, A. Moreno, E. Sesa (FIB,UPC) - Bath, July 1990
  7.  *
  8.  */
  9.  
  10. /* $Id: feelflex.lex,v 1.1 1992/11/26 15:51:06 pab Exp pab $ */
  11. /* $Log:
  12. */
  13. %{
  14.  
  15. #include "defs.h"
  16. /* We need to add an extra parameter */
  17. #ifdef YY_DECL
  18. #undef YY_DECL
  19. #ifdef YY_USE_PROTOS
  20. #define YY_DECL  int yylex YY_PROTO((LispObject *stacktop))
  21. #else
  22. #define YY_DECL  int yylex (stacktop) LispObject *stacktop;
  23. #endif
  24. #endif
  25. /* Emergency fileno */
  26.  
  27. #ifndef HAS_READFILENO
  28. #define fileno(fh) (fh == stdin ? 0 \
  29.             : (fh == stdout ? 1 \
  30.                        : (fh == stderr ? 2 : 3)))
  31. #endif /* HAS_READFILENO */
  32.  
  33. #include <string.h>
  34. #include <ctype.h>
  35. #include "defs.h"
  36. #include "structs.h"
  37. #include "funcalls.h"
  38. #include "global.h"
  39. #include "symboot.h"
  40. #include "error.h"
  41.  
  42. #include "lex_global.h"
  43.  
  44. #ifdef __STDC__
  45. #define OF(ansi, kr, krargs) ansi
  46. #define PROTO(args) args
  47. #else
  48. #define OF(ansi, kr, krargs) kr krargs
  49. #define PROTO(args) ()
  50. #endif
  51.  
  52. #ifdef __STDC__
  53.  
  54. /*
  55. #ifndef DONT_HAVE_STDLIB_H
  56. #include <stdlib.h>
  57. #else
  58. void *malloc( unsigned );
  59. void free( void* );
  60. #endif
  61. */
  62.  
  63. extern int read(int, char *, unsigned);
  64. #else
  65. extern double atof();
  66. #endif
  67.  
  68. /* the values returned */
  69. double flex_floatval;
  70. long flex_ratnumval, flex_ratdenval;
  71. long flex_intval;
  72. char flex_charval;
  73. char flex_stringval[1024];    /* I don't like fixed array sizes */
  74. char flex_idval[256];
  75. pptoken pptok;            /* for backward compatibility */
  76. int lex_input_line_number=1;    /* Needs changing for shared memory */
  77.  
  78. static double convert_float PROTO((void));
  79. static long convert_integer PROTO((char *, int));
  80. static long int_with_base PROTO((char *, int *));
  81. static void convert_rational PROTO((void));
  82. static void convert_string PROTO((void));
  83. static char convert_character PROTO((void));
  84. static void tidy_id PROTO((void));
  85. int escaped_id PROTO((char*));
  86. char *visible PROTO((char));
  87.  
  88. /* Hack the lex reader */
  89.  
  90. #ifdef YY_INPUT
  91. #undef YY_INPUT
  92. #endif
  93.  
  94. #ifdef HAS_READFILENO
  95. #define YY_INPUT(buf,result,max_size) \
  96.   if ( (result = system_read( fileno(yyin), (char *) buf, max_size )) < 0 ) \
  97.     {                         \
  98.       perror("Some bad thing happened");\
  99.       exit(0);                    \
  100.     }            
  101. #else
  102. #define YY_INPUT(buf,result,max_size) \
  103. {                     \
  104.   int len;                \
  105.   char *ret;                \
  106.   fprintf(stderr,"Reading from: %d %d\n",buf,max_size);    \
  107.   if (fgets(buf,max_size,yyin)==NULL)            \
  108.     result=0;                \
  109.   else                    \
  110.     result=strlen(buf);            \
  111. }
  112.  
  113. #endif /* HAS_READFILENO */
  114.  
  115. %}
  116.  
  117. /* forward references */
  118.  
  119. digit        [0-9]
  120. alphabetic    [A-Za-z]
  121. alphanumeric    [0-9A-Za-z]
  122. special        [\\\#()"',;`]
  123. non-alpha    [^0-9A-Za-z]
  124. ordinary    [!$%&*/:<=>?@[\]^_{}~]
  125. sign        [+-]
  126.  
  127. /* tokens */
  128.  
  129. dot        "."
  130. pair-begin    "("
  131. pair-end    ")"
  132. quotation    "'"
  133. antiquotation    "`"
  134. unquotation    ","
  135. unquotesplice    ",@"
  136. extension    "#"
  137. space        [ ]
  138. tab        \t
  139. newline        \n
  140. whitespace    {space}|{tab}|{newline}
  141. comment-begin    ";"
  142. comment-end    {newline}
  143. comment        {comment-begin}.*{comment-end}
  144.  
  145. /*delimeter    {whitespace}|{pair-begin}|{pair-end}|{string-begin}|{string-end}|{comment-begin}*/
  146.  
  147.  
  148. /* character syntax */
  149.  
  150. character-extension    "\\"
  151. control-extension    "^"
  152. special-name    alert|backspace|delete|formfeed|linefeed|newline|return|tab|space|vertical-tab
  153. literal-name    {alphanumeric}|{non-alpha}
  154. control-name    {control-extension}{literal-name}
  155. character-name    {literal-name}|{control-name}|{special-name}
  156. character    {extension}{character-extension}{character-name}
  157.  
  158. /* number syntax */
  159.  
  160. /* integers */
  161.  
  162. digit2        [01]
  163. digit8        [0-7]
  164. digit10        [0-9]
  165. digit16        [0-9A-Fa-f]
  166. extended-digit    [0-9A-Za-z]
  167.  
  168. ubinary        {extension}[bB]{digit2}+
  169. uoctal        {extension}[oO]{digit8}+
  170. udecimal    {digit10}+
  171. uhexadecimal    {extension}[xX]{digit16}+
  172. uinteger-with-base    {extension}{udecimal}[rR]{extended-digit}+
  173. uinteger    {ubinary}|{uoctal}|{udecimal}|{uhexadecimal}|{uinteger-with-base}
  174.  
  175. binary        {sign}?{ubinary}
  176. octal        {sign}?{uoctal}
  177. decimal        {sign}?{udecimal}
  178. hexadecimal    {sign}?{uhexadecimal}
  179. integer-with-base    {sign}?{uinteger-with-base}
  180.  
  181. /* rationals */
  182.  
  183. ratio-separator    "/"
  184. urational    {uinteger}{ratio-separator}{uinteger}
  185. rational    {sign}?{urational}
  186.  
  187. /* floats */
  188.  
  189. float-separator    "."
  190. expt-mark    [edED]
  191. exponent    {expt-mark}{sign}?{udecimal}
  192. ufloat        {udecimal}{exponent}|{float-separator}{udecimal}{exponent}?|{udecimal}{float-separator}{udecimal}?{exponent}?
  193. float        {sign}?{ufloat}
  194.  
  195. /* strings */
  196. /* we do these by hand, as it's easier that way */
  197.  
  198. string-begin    \"
  199.  
  200. /* identifiers */
  201.  
  202. multiple-escape    \|
  203. single-escape    \\
  204. point        \.
  205. non-escape    [^|\\]
  206. single-escaped    {single-escape}(.|\n)
  207. multiple-escaped    {multiple-escape}({single-escaped}|{non-escape})*{multiple-escape}
  208. escaped        {single-escaped}|{multiple-escaped}
  209. non-digit    {alphabetic}|{ordinary}|{escaped}
  210. constituent    {non-digit}|{digit}|{sign}|{point}
  211. normal-identifier    {non-digit}{constituent}*
  212. sign-identifier    {sign}|{sign}({non-digit}|{sign}|{point}){constituent}*
  213. point-identifier    {point}({non-digit}|{sign}|{point}){constituent}*
  214. peculiar-identifier    {sign-identifier}|{point-identifier}
  215. identifier    {normal-identifier}|{peculiar-identifier}
  216.  
  217. %%
  218.  
  219. <<EOF>>        { return(END_OF_STREAM); }
  220.  
  221. {comment}    {lex_input_line_number++;}
  222.  
  223. {whitespace}    {if (yytext[0]=='\n') lex_input_line_number++;}
  224.  
  225. {dot}        { return(DOT); }
  226.  
  227. {pair-begin}    { return(OPEN_PAIR); }
  228.  
  229. {pair-end}    { return(CLOSE_PAIR); }
  230.  
  231. {quotation}    {
  232.                   pptok.lispval=get_symbol(stacktop,"quote");
  233.           return(WRAPPER);
  234.         }
  235.  
  236. {antiquotation}    { 
  237.                   pptok.lispval=get_symbol(stacktop,"quasiquote");
  238.           return(WRAPPER);
  239.         }
  240.  
  241. {unquotation}    { pptok.lispval=get_symbol(stacktop,"unquote");
  242.           return(WRAPPER);
  243.         }
  244.  
  245. {unquotesplice}    { pptok.lispval=get_symbol(stacktop,"unquote-splicing");
  246.           return(WRAPPER);
  247.         }
  248.  
  249. {extension}    { return(EXTENSION); }
  250.  
  251. {float}        { flex_floatval = convert_float();
  252.           pptok.lispval = allocate_float(stacktop,flex_floatval);
  253.           return(FLOAT); }
  254.  
  255. {rational}    { convert_rational(); /* XXX: ?? */
  256.           return(RATIONAL); }
  257.  
  258. {binary}    { flex_intval = convert_integer(yytext, 2);
  259.           pptok.lispval = allocate_integer(stacktop,flex_intval);
  260.           return(INTEGER); }
  261.  
  262. {octal}        { flex_intval = convert_integer(yytext, 8);
  263.           pptok.lispval = allocate_integer(stacktop,flex_intval);
  264.           return(INTEGER); }
  265.  
  266. {decimal}    { flex_intval = atol(yytext);
  267.           pptok.lispval = allocate_integer(stacktop,flex_intval);
  268.           return(INTEGER); }
  269.  
  270. {hexadecimal}    { flex_intval = convert_integer(yytext, 16);
  271.           pptok.lispval = allocate_integer(stacktop,flex_intval);
  272.           return(INTEGER); }
  273.  
  274. {integer-with-base}    { int returns;
  275.               flex_intval = int_with_base(yytext, &returns);
  276.               if (returns != yyleng) yyless(returns);
  277.               pptok.lispval = allocate_integer(stacktop,flex_intval);
  278.               return(INTEGER); }
  279.  
  280. {string-begin}    { convert_string();
  281.           pptok.lispval = allocate_string(stacktop,flex_stringval,
  282.                              strlen(flex_stringval));
  283.           return(STRING); }
  284.  
  285. {character}    { flex_charval = convert_character();
  286.           pptok.lispval = allocate_char(stacktop,flex_charval);
  287.           return(CHARACTER); }
  288.  
  289. {identifier}    { tidy_id();
  290.           pptok.lispval = get_symbol(stacktop,flex_idval);
  291.           return(IDENTIFIER); }
  292.  
  293. .        { fprintf(stderr, "\n*** Illegal Character '%s' ignored\n",
  294.               visible(*yytext)); }
  295.  
  296. %%
  297.  
  298. /* +#o123 or -#o123 or #o123 or binary or hex */
  299. static long convert_integer OF ((char *text, int base),
  300. (text, base),
  301. char *text;
  302. int base;)
  303. {
  304.   switch (*text) {
  305.   case '+':
  306.     return strtol(text + 3, 0, base);
  307.   case '-':
  308.     return -strtol(text + 3, 0, base);
  309.   default:
  310.     return strtol(text + 2, 0, base);
  311.   }
  312. }
  313.  
  314. /* +#5r123 or -#5r123 or #5r123 */
  315. static long int_with_base OF ((char *text, int *ret),
  316. (text, ret),
  317. char *text;
  318. int *ret;)
  319. {
  320.   char *val;
  321.   int base;
  322.   long value;
  323.  
  324.   switch (*text) {
  325.   case '+':
  326.     base = (int)strtol(text + 2, &val, 10);
  327.     value = strtol(val + 1, &val, base);
  328.     break;
  329.   case '-':
  330.     base = (int)strtol(text + 2, &val, 10);
  331.     value = -strtol(val + 1, &val, base);
  332.     break;
  333.   default:
  334.     base = (int)strtol(text + 1, &val, 10);
  335.     value = strtol(val + 1, &val, base);
  336.     break;
  337.   }
  338.  
  339.   /* all characters used? */
  340.   *ret = (val - text)/sizeof(char);
  341.  
  342.   return value;
  343. }
  344.  
  345. /* 123 or #o123 or #5r123 */
  346. static long convert_unumber OF ((char *text),
  347. (text),
  348. char *text;)
  349. {
  350.   char *val;
  351.   int base;
  352.  
  353.   if (*text == '#')
  354.     switch (text[1]) {
  355.     case 'b':
  356.     case 'B':
  357.       return convert_integer(text, 2);
  358.     case 'o':
  359.     case 'O':
  360.       return convert_integer(text, 8);
  361.     case 'x':
  362.     case 'X':
  363.       return convert_integer(text, 16);
  364.     default:
  365.       base = (int)strtol(text + 1, &val, 10);
  366.       return strtol(val + 1, 0, base);
  367.     }
  368.  
  369.   return atol(text);
  370. }
  371.  
  372. /* +num/num or -num/num or num/num */
  373. static void convert_rational OF ((void),
  374. (),
  375. /**/)
  376. {
  377.   char *text = yytext;
  378.   int sign;
  379.  
  380.   if (*text == '+') {
  381.     sign = 1;
  382.     text++;
  383.   }
  384.   else if (*text == '-') {
  385.     sign = -1;
  386.     text++;
  387.   }
  388.   else {
  389.     sign = 1;
  390.   }
  391.  
  392.   flex_ratnumval = sign*convert_unumber(text);
  393.   text = strchr(text, '/');
  394.   flex_ratdenval = convert_unumber(text + 1);
  395.  
  396. }
  397.  
  398. /* #\a or #\^a or #\alert */
  399. /* ASCII dependent */
  400. static char convert_character OF ((void),
  401. (),
  402. /**/)
  403. {
  404.   register int i;
  405.   for(i=0;i<yyleng;i++)
  406.     if (yytext[i]=='\n') lex_input_line_number++;
  407.   if (yyleng == 4) {        /* #\^a or #\^A */
  408.     if ('a' <= yytext[3] && yytext[3] <= 'z')
  409.       return (yytext[3] - 'a' + 'A') & 077;
  410.     else
  411.       return yytext[3] & 077;
  412.   }
  413.  
  414.   if (yyleng > 4) {        /* #\alert etc */
  415.     switch (yytext[2]) {
  416.     case 'a':            /* alert 07 */
  417.       return 07;        /* Stardent is non-ansi here */
  418.     case 'b':            /* backspace 010 */
  419.       return '\b';
  420.     case 'd':            /* delete 0177 */
  421.       return 0177;
  422.     case 'f':            /* formfeed 014 */
  423.       return '\f';
  424.     case 'l':            /* linefeed 012 */
  425.     case 'n':                   /* newline 012 */
  426.       return '\n';
  427.     case 'r':            /* return 015 */
  428.       return '\r';
  429.     case 't':            /* tab 011 */
  430.       return '\t';
  431.     case 's':            /* space 040 */
  432.       return ' ';
  433.     case 'v':            /* vertical-tab 013 */
  434.       return '\v';
  435.     }
  436.   }  
  437.   return yytext[2];
  438. }
  439.  
  440. /* get all the escapes out of the identifier: produce the internal form */
  441. static void tidy_id OF ((void),
  442. (),
  443. /**/)
  444. {
  445.   int escaped = 0;
  446.   int i, j;
  447.  
  448.   for (i = 0; yytext[i]; i++)
  449.     if (yytext[i] == '|' ||
  450.     yytext[i] == '\\') {
  451.       escaped = 1;
  452.       break;
  453.     }
  454.     
  455.   if (!escaped) {
  456.     strcpy(flex_idval, yytext);
  457.     return;
  458.   }
  459.  
  460.   i = 0;
  461.   j = 0;
  462.   while (yytext[j]) {
  463.     if (yytext[j] == '\\') {
  464.       if (yytext[j+1] == '|') {
  465.         flex_idval[i++] = '|';
  466.         j++;
  467.       }
  468.       else if (yytext[j+1] == '\\') {
  469.         flex_idval[i++] = '\\';
  470.         j++;
  471.       }
  472.       else if (yytext[j+1] == '\n') {
  473.     lex_input_line_number++;
  474.     flex_idval[i++] = '\n';
  475.     j++;
  476.       }
  477.       j++;
  478.     } else if (yytext[j] == '|') j++;
  479.     else {            /* Copy the text, checking for newline */
  480.       if ((flex_idval[i++] = yytext[j++])=='\n')
  481.     lex_input_line_number++;
  482.     }
  483.   }
  484.  
  485.   flex_idval[i] = 0;
  486. }
  487.  
  488. /* do we need to escape this id when printing?
  489.  * yes if (1) it contains a dodgy character
  490.  *        (2) it is the id of zero length
  491.  *        (3) it starts with the syntax of a number
  492.  *
  493.  * ASCII dependent
  494.  */
  495. int escaped_id OF ((char *id),
  496. (id),
  497. char *id;)
  498. {
  499.   int i;
  500.  
  501.   for (i = 0; id[i]; i++)
  502.     if (id[i] < 32 || id[i] > 126 || id[i] == '|' || id[i] == '\\') return 1;
  503.  
  504.   if (strpbrk(id, "|\\#()\"',;` ") ||
  505.       id[0] == 0 ||        /* zero length id */
  506.       isdigit(id[0]) ||                    /* 123 */
  507.       (id[0] == '.' && !id[1]) ||            /* |.| */
  508.       (id[0] == '.' && id[1] && isdigit(id[1])) ||    /* .123 */
  509.       ((id[0] == '+' || id[0] == '-') &&
  510.     id[1] && (isdigit(id[1]) ||            /* +123 */
  511.               (id[1] == '.' && id[2] && isdigit(id[2]))))) /* +.123 */
  512.     return 1;
  513.   else
  514.     return 0;
  515. }
  516.  
  517. static void convert_string OF ((void),
  518. (),
  519. /**/)
  520. {
  521.   int ch, prevch;
  522.   int i;
  523.  
  524.   i = 0;
  525.   while ((ch = input()) != '"') {
  526.     if (ch == '\\')
  527.       switch (ch = input()) {
  528.       case '"':
  529.       case '\\':
  530.     flex_stringval[i++] = ch;
  531.     break;
  532.       case 'n':
  533.       case 'N':
  534.     flex_stringval[i++] = '\n';
  535.     break;
  536.       case 'x':
  537.       case 'X':
  538.     prevch = ch;
  539.     if (isxdigit(ch = input())) {
  540.       char val = 0;
  541.       int count;
  542.       for (count = 0; count < 4 && isxdigit(ch); count++, ch = input()) {
  543.         val = 16*val;
  544.         if (isupper(ch)) val += ch - 'A' + 10;
  545.         else if (islower(ch)) val += ch - 'a' + 10;
  546.         else val += ch - '0';
  547.       }
  548.       flex_stringval[i++] = val;
  549.     }
  550.     else flex_stringval[i++] = prevch;
  551.     unput(ch);
  552.     break;
  553.       default:
  554.     flex_stringval[i++] = ch;
  555.     break;
  556.       }
  557.     else flex_stringval[i++] = ch;
  558.     if (ch == '\n') lex_input_line_number++;
  559.   }
  560.  
  561.   flex_stringval[i] = 0;
  562.  
  563. }
  564.  
  565. static double convert_float OF ((void),
  566. (),
  567. /**/)
  568. {
  569. #ifdef __ANSI__
  570.   extern double atof(char *);
  571. #else
  572.   extern double atof();
  573. #endif
  574.  
  575.   char buf[256];
  576.   int i;
  577.  
  578.   for (i = 0; yytext[i]; i++)
  579.     buf[i] = (yytext[i] == 'd' || yytext[i] == 'D') ? 'E' : yytext[i];
  580.   buf[i] = 0;
  581.  
  582.   return atof(buf);
  583. }
  584.  
  585. /* more ASCII dependence */
  586. char *visible OF ((char ch),
  587. (ch),
  588. char ch;)
  589. {
  590.   static char buf[10];
  591.   char *ptr = buf;
  592.  
  593.   if (ch == 127) return "^?";
  594.  
  595.   if (ch > 127) {
  596.     *ptr++ = 'M';
  597.     *ptr++ = '-';
  598.     ch = ch & 0x7f;
  599.   }
  600.  
  601.   if (ch < 32) {
  602.     *ptr++ = '^';
  603.     ch += '@';
  604.   }
  605.  
  606.   *ptr++ = ch;
  607.   *ptr = 0;
  608.  
  609.   return buf;
  610. }
  611.  
  612. #ifdef WITH_FUDGE
  613. #include "yyfudge.c"
  614. #endif
  615.